home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / rts / xprim.scm < prev   
Text File  |  1995-10-13  |  3KB  |  126 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3. ; Hairier exceptions & interrupts.
  4. ; Enable generic arithmetic, informative error messages, etc.
  5.  
  6. ; Deal with optional arguments, etc. to primitives.
  7. ; This is not necessarily the cleanest way to do this, and certainly not
  8. ; the most efficient, but for the time being it's the most expedient.
  9.  
  10. ; We don't want to depend on tables.  But if we did, we might do this:
  11. ;(define (closure-hash closure)
  12. ;  (let ((cv (vector-ref (closure-template closure) 0)))  ;template-ref
  13. ;    (do ((h 0 (+ h (code-vector-ref cv i)))
  14. ;         (i (- (code-vector-length cv) 1) (- i 1)))
  15. ;        ((< i 0) h))))
  16. ;(define wna-handlers (make-table closure-hash))
  17.  
  18. (define-exception-handler (enum op check-nargs=)
  19.   (lambda (opcode args)
  20.     (let ((probe (assq (car args) *wna-handlers*)))
  21.       (if probe
  22.       ((cdr probe) (cadr args))
  23.       (signal-exception opcode args)))))
  24.  
  25. (define *wna-handlers* '())
  26.  
  27. (define (define-wna-handler proc handler)
  28.   (set! *wna-handlers* (cons (cons proc handler) *wna-handlers*)))
  29.  
  30. (define op/check-nargs= (enum op check-nargs=))
  31.  
  32. (define (wna-lose proc args)
  33.   (signal-exception op/check-nargs= (list proc args)))
  34.  
  35. (define-wna-handler + (lambda (args) (reduce + 0 args)))
  36.  
  37. (define-wna-handler * (lambda (args) (reduce * 1 args)))
  38.  
  39. (define-wna-handler -
  40.   (lambda (args)
  41.     (if (and (not (null? args))
  42.           (null? (cdr args)))
  43.     (- 0 (car args))
  44.     (wna-lose - args))))
  45.  
  46. (define-wna-handler /
  47.   (lambda (args)
  48.     (if (and (not (null? args))
  49.          (null? (cdr args)))
  50.     (/ 1 (car args))
  51.     (wna-lose / args))))
  52.  
  53. (define-wna-handler make-vector
  54.   (lambda (args)
  55.     (if (and (not (null? args))
  56.          (null? (cdr args)))
  57.     (make-vector (car args) (unspecific))
  58.     (wna-lose make-vector args))))
  59.  
  60. (define-wna-handler make-string
  61.   (lambda (args)
  62.     (if (and (not (null? args))
  63.          (null? (cdr args)))
  64.     (make-string (car args) #\?)
  65.     (wna-lose make-string args))))
  66.  
  67. (define-wna-handler apply
  68.   (lambda (args)
  69.     (if (null? args)
  70.     (wna-lose apply args))
  71.     (apply (car args)
  72.            (let recur ((l (cdr args)))
  73.          (if (null? (cdr l))
  74.              (car l)
  75.              (cons (car l) (recur (cdr l))))))))
  76.  
  77. (define-wna-handler read-char
  78.   (lambda (args)
  79.     (if (null? args)
  80.     (read-char (input-port-option args))
  81.     (wna-lose read-char args))))
  82.  
  83. (define-wna-handler peek-char
  84.   (lambda (args)
  85.     (if (null? args)
  86.     (peek-char (input-port-option args))
  87.     (wna-lose peek-char args))))
  88.  
  89. (define-wna-handler char-ready?
  90.   (lambda (args)
  91.     (if (null? args)
  92.     (char-ready? (input-port-option args))
  93.     (wna-lose char-ready? args))))
  94.  
  95. (define-wna-handler write-char
  96.   (lambda (args)
  97.     (if (and (not (null? args))
  98.          (null? (cdr args)))
  99.     (write-char (car args) (output-port-option (cdr args)))
  100.     (wna-lose write-char args))))
  101.  
  102. (define-wna-handler error
  103.   (lambda (args)
  104.     (really-signal-condition (cons 'error args))))
  105.  
  106. (define (comparison-wna compare)    ;Not really R4RS compliant.
  107.   (lambda (args)
  108.     (if (and (not (null? args))
  109.          (not (null? (cdr args))))
  110.     (let loop ((x (car args))
  111.            (args (cdr args)))
  112.       (let ((y (car args))
  113.         (args (cdr args)))
  114.         (if (compare x y)
  115.         (if (null? args)
  116.             #t
  117.             (loop y args))
  118.         #f)))
  119.     (wna-lose compare args))))
  120.  
  121. (define-wna-handler = (comparison-wna =))
  122. (define-wna-handler < (comparison-wna <))
  123. (define-wna-handler > (comparison-wna >))
  124. (define-wna-handler <= (comparison-wna <=))
  125. (define-wna-handler >= (comparison-wna >=))
  126.